home *** CD-ROM | disk | FTP | other *** search
/ Mac-Source 1994 July / Mac-Source_July_1994.iso / Other Langs / Tickle-4.0 (tcl) / tcl / src / tclProc.c < prev    next >
Encoding:
C/C++ Source or Header  |  1993-10-25  |  16.3 KB  |  630 lines  |  [TEXT/MPS ]
  1. #ifdef MPW
  2. #    pragma segment TCL_PROC
  3. #endif
  4.  
  5. /* 
  6.  * tclProc.c --
  7.  *
  8.  *    This file contains routines that implement Tcl procedures,
  9.  *    including the "proc" and "uplevel" commands.
  10.  *
  11.  * Copyright (c) 1987-1993 The Regents of the University of California.
  12.  * All rights reserved.
  13.  *
  14.  * Permission is hereby granted, without written agreement and without
  15.  * license or royalty fees, to use, copy, modify, and distribute this
  16.  * software and its documentation for any purpose, provided that the
  17.  * above copyright notice and the following two paragraphs appear in
  18.  * all copies of this software.
  19.  * 
  20.  * IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
  21.  * DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
  22.  * OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
  23.  * CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  24.  *
  25.  * THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
  26.  * INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
  27.  * AND FITNESS FOR A PARTICULAR PURPOSE.  THE SOFTWARE PROVIDED HEREUNDER IS
  28.  * ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
  29.  * PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
  30.  */
  31.  
  32. #ifndef lint
  33. static char rcsid[] = "$Header: /user6/ouster/tcl/RCS/tclProc.c,v 1.67 93/08/18 16:06:59 ouster Exp $ SPRITE (Berkeley)";
  34. #endif
  35.  
  36. #include "tclInt.h"
  37.  
  38. /*
  39.  * Forward references to procedures defined later in this file:
  40.  */
  41.  
  42. static void    CleanupProc _ANSI_ARGS_((Proc *procPtr));
  43. static  int    InterpProc _ANSI_ARGS_((ClientData clientData,
  44.             Tcl_Interp *interp, int argc, char **argv));
  45. static  void    ProcDeleteProc _ANSI_ARGS_((ClientData clientData));
  46.  
  47. /*
  48.  *----------------------------------------------------------------------
  49.  *
  50.  * Tcl_ProcCmd --
  51.  *
  52.  *    This procedure is invoked to process the "proc" Tcl command.
  53.  *    See the user documentation for details on what it does.
  54.  *
  55.  * Results:
  56.  *    A standard Tcl result value.
  57.  *
  58.  * Side effects:
  59.  *    A new procedure gets created.
  60.  *
  61.  *----------------------------------------------------------------------
  62.  */
  63.  
  64.     /* ARGSUSED */
  65. int
  66. Tcl_ProcCmd(dummy, interp, argc, argv)
  67.     ClientData dummy;            /* Not used. */
  68.     Tcl_Interp *interp;            /* Current interpreter. */
  69.     int argc;                /* Number of arguments. */
  70.     char **argv;            /* Argument strings. */
  71. {
  72.     register Interp *iPtr = (Interp *) interp;
  73.     register Proc *procPtr;
  74.     int result, argCount, i;
  75.     char **argArray = NULL;
  76.     Arg *lastArgPtr;
  77.     register Arg *argPtr = NULL;    /* Initialization not needed, but
  78.                      * prevents compiler warning. */
  79.  
  80.     if (argc != 4) {
  81.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  82.         " name args body\"", (char *) NULL);
  83.     return TCL_ERROR;
  84.     }
  85.  
  86.     procPtr = (Proc *) ckalloc(sizeof(Proc));
  87.     procPtr->iPtr = iPtr;
  88.     procPtr->refCount = 1;
  89.     procPtr->command = (char *) ckalloc((unsigned) strlen(argv[3]) + 1);
  90.     strcpy(procPtr->command, argv[3]);
  91.     procPtr->argPtr = NULL;
  92.  
  93.     /*
  94.      * Break up the argument list into argument specifiers, then process
  95.      * each argument specifier.
  96.      */
  97.  
  98.     result = Tcl_SplitList(interp, argv[2], &argCount, &argArray);
  99.     if (result != TCL_OK) {
  100.     goto procError;
  101.     }
  102.     lastArgPtr = NULL;
  103.     for (i = 0; i < argCount; i++) {
  104.     int fieldCount, nameLength, valueLength;
  105.     char **fieldValues;
  106.  
  107.     /*
  108.      * Now divide the specifier up into name and default.
  109.      */
  110.  
  111.     result = Tcl_SplitList(interp, argArray[i], &fieldCount,
  112.         &fieldValues);
  113.     if (result != TCL_OK) {
  114.         goto procError;
  115.     }
  116.     if (fieldCount > 2) {
  117.         ckfree((char *) fieldValues);
  118.         Tcl_AppendResult(interp,
  119.             "too many fields in argument specifier \"",
  120.             argArray[i], "\"", (char *) NULL);
  121.         result = TCL_ERROR;
  122.         goto procError;
  123.     }
  124.     if ((fieldCount == 0) || (*fieldValues[0] == 0)) {
  125.         ckfree((char *) fieldValues);
  126.         Tcl_AppendResult(interp, "procedure \"", argv[1],
  127.             "\" has argument with no name", (char *) NULL);
  128.         result = TCL_ERROR;
  129.         goto procError;
  130.     }
  131.     nameLength = strlen(fieldValues[0]) + 1;
  132.     if (fieldCount == 2) {
  133.         valueLength = strlen(fieldValues[1]) + 1;
  134.     } else {
  135.         valueLength = 0;
  136.     }
  137.     argPtr = (Arg *) ckalloc((unsigned)
  138.         (sizeof(Arg) - sizeof(argPtr->name) + nameLength
  139.         + valueLength));
  140.     if (lastArgPtr == NULL) {
  141.         procPtr->argPtr = argPtr;
  142.     } else {
  143.         lastArgPtr->nextPtr = argPtr;
  144.     }
  145.     lastArgPtr = argPtr;
  146.     argPtr->nextPtr = NULL;
  147.     strcpy(argPtr->name, fieldValues[0]);
  148.     if (fieldCount == 2) {
  149.         argPtr->defValue = argPtr->name + nameLength;
  150.         strcpy(argPtr->defValue, fieldValues[1]);
  151.     } else {
  152.         argPtr->defValue = NULL;
  153.     }
  154.     ckfree((char *) fieldValues);
  155.     }
  156.  
  157.     Tcl_CreateCommand(interp, argv[1], InterpProc, (ClientData) procPtr,
  158.         ProcDeleteProc);
  159.     ckfree((char *) argArray);
  160.     return TCL_OK;
  161.  
  162.     procError:
  163.     ckfree(procPtr->command);
  164.     while (procPtr->argPtr != NULL) {
  165.     argPtr = procPtr->argPtr;
  166.     procPtr->argPtr = argPtr->nextPtr;
  167.     ckfree((char *) argPtr);
  168.     }
  169.     ckfree((char *) procPtr);
  170.     if (argArray != NULL) {
  171.     ckfree((char *) argArray);
  172.     }
  173.     return result;
  174. }
  175.  
  176. /*
  177.  *----------------------------------------------------------------------
  178.  *
  179.  * TclGetFrame --
  180.  *
  181.  *    Given a description of a procedure frame, such as the first
  182.  *    argument to an "uplevel" or "upvar" command, locate the
  183.  *    call frame for the appropriate level of procedure.
  184.  *
  185.  * Results:
  186.  *    The return value is -1 if an error occurred in finding the
  187.  *    frame (in this case an error message is left in interp->result).
  188.  *    1 is returned if string was either a number or a number preceded
  189.  *    by "#" and it specified a valid frame.  0 is returned if string
  190.  *    isn't one of the two things above (in this case, the lookup
  191.  *    acts as if string were "1").  The variable pointed to by
  192.  *    framePtrPtr is filled in with the address of the desired frame
  193.  *    (unless an error occurs, in which case it isn't modified).
  194.  *
  195.  * Side effects:
  196.  *    None.
  197.  *
  198.  *----------------------------------------------------------------------
  199.  */
  200.  
  201. int
  202. TclGetFrame(interp, string, framePtrPtr)
  203.     Tcl_Interp *interp;        /* Interpreter in which to find frame. */
  204.     char *string;        /* String describing frame. */
  205.     CallFrame **framePtrPtr;    /* Store pointer to frame here (or NULL
  206.                  * if global frame indicated). */
  207. {
  208.     register Interp *iPtr = (Interp *) interp;
  209.     int curLevel, level, result;
  210.     CallFrame *framePtr;
  211.  
  212.     /*
  213.      * Parse string to figure out which level number to go to.
  214.      */
  215.  
  216.     result = 1;
  217.     curLevel = (iPtr->varFramePtr == NULL) ? 0 : iPtr->varFramePtr->level;
  218.     if (*string == '#') {
  219.     if (Tcl_GetInt(interp, string+1, &level) != TCL_OK) {
  220.         return -1;
  221.     }
  222.     if (level < 0) {
  223.         levelError:
  224.         Tcl_AppendResult(interp, "bad level \"", string, "\"",
  225.             (char *) NULL);
  226.         return -1;
  227.     }
  228.     } else if (isdigit(UCHAR(*string))) {
  229.     if (Tcl_GetInt(interp, string, &level) != TCL_OK) {
  230.         return -1;
  231.     }
  232.     level = curLevel - level;
  233.     } else {
  234.     level = curLevel - 1;
  235.     result = 0;
  236.     }
  237.  
  238.     /*
  239.      * Figure out which frame to use, and modify the interpreter so
  240.      * its variables come from that frame.
  241.      */
  242.  
  243.     if (level == 0) {
  244.     framePtr = NULL;
  245.     } else {
  246.     for (framePtr = iPtr->varFramePtr; framePtr != NULL;
  247.         framePtr = framePtr->callerVarPtr) {
  248.         if (framePtr->level == level) {
  249.         break;
  250.         }
  251.     }
  252.     if (framePtr == NULL) {
  253.         goto levelError;
  254.     }
  255.     }
  256.     *framePtrPtr = framePtr;
  257.     return result;
  258. }
  259.  
  260. /*
  261.  *----------------------------------------------------------------------
  262.  *
  263.  * Tcl_UplevelCmd --
  264.  *
  265.  *    This procedure is invoked to process the "uplevel" Tcl command.
  266.  *    See the user documentation for details on what it does.
  267.  *
  268.  * Results:
  269.  *    A standard Tcl result value.
  270.  *
  271.  * Side effects:
  272.  *    See the user documentation.
  273.  *
  274.  *----------------------------------------------------------------------
  275.  */
  276.  
  277.     /* ARGSUSED */
  278. int
  279. Tcl_UplevelCmd(dummy, interp, argc, argv)
  280.     ClientData dummy;            /* Not used. */
  281.     Tcl_Interp *interp;            /* Current interpreter. */
  282.     int argc;                /* Number of arguments. */
  283.     char **argv;            /* Argument strings. */
  284. {
  285.     register Interp *iPtr = (Interp *) interp;
  286.     int result;
  287.     CallFrame *savedVarFramePtr, *framePtr;
  288.  
  289.     if (argc < 2) {
  290.     uplevelSyntax:
  291.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  292.         " ?level? command ?arg ...?\"", (char *) NULL);
  293.     return TCL_ERROR;
  294.     }
  295.  
  296.     /*
  297.      * Find the level to use for executing the command.
  298.      */
  299.  
  300.     result = TclGetFrame(interp, argv[1], &framePtr);
  301.     if (result == -1) {
  302.     return TCL_ERROR;
  303.     }
  304.     argc -= (result+1);
  305.     if (argc == 0) {
  306.     goto uplevelSyntax;
  307.     }
  308.     argv += (result+1);
  309.  
  310.     /*
  311.      * Modify the interpreter state to execute in the given frame.
  312.      */
  313.  
  314.     savedVarFramePtr = iPtr->varFramePtr;
  315.     iPtr->varFramePtr = framePtr;
  316.  
  317.     /*
  318.      * Execute the residual arguments as a command.
  319.      */
  320.  
  321.     if (argc == 1) {
  322.     result = Tcl_Eval(interp, argv[0]);
  323.     } else {
  324.     char *cmd;
  325.  
  326.     cmd = Tcl_Concat(argc, argv);
  327.     result = Tcl_Eval(interp, cmd);
  328.     ckfree(cmd);
  329.     }
  330.     if (result == TCL_ERROR) {
  331.     char msg[60];
  332.     sprintf(msg, "\n    (\"uplevel\" body line %d)", interp->errorLine);
  333.     Tcl_AddErrorInfo(interp, msg);
  334.     }
  335.  
  336.     /*
  337.      * Restore the variable frame, and return.
  338.      */
  339.  
  340.     iPtr->varFramePtr = savedVarFramePtr;
  341.     return result;
  342. }
  343.  
  344. /*
  345.  *----------------------------------------------------------------------
  346.  *
  347.  * TclFindProc --
  348.  *
  349.  *    Given the name of a procedure, return a pointer to the
  350.  *    record describing the procedure.
  351.  *
  352.  * Results:
  353.  *    NULL is returned if the name doesn't correspond to any
  354.  *    procedure.  Otherwise the return value is a pointer to
  355.  *    the procedure's record.
  356.  *
  357.  * Side effects:
  358.  *    None.
  359.  *
  360.  *----------------------------------------------------------------------
  361.  */
  362.  
  363. Proc *
  364. TclFindProc(iPtr, procName)
  365.     Interp *iPtr;        /* Interpreter in which to look. */
  366.     char *procName;        /* Name of desired procedure. */
  367. {
  368.     Tcl_HashEntry *hPtr;
  369.     Command *cmdPtr;
  370.  
  371.     hPtr = Tcl_FindHashEntry(&iPtr->commandTable, procName);
  372.     if (hPtr == NULL) {
  373.     return NULL;
  374.     }
  375.     cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
  376.     if (cmdPtr->proc != InterpProc) {
  377.     return NULL;
  378.     }
  379.     return (Proc *) cmdPtr->clientData;
  380. }
  381.  
  382. /*
  383.  *----------------------------------------------------------------------
  384.  *
  385.  * TclIsProc --
  386.  *
  387.  *    Tells whether a command is a Tcl procedure or not.
  388.  *
  389.  * Results:
  390.  *    If the given command is actuall a Tcl procedure, the
  391.  *    return value is the address of the record describing
  392.  *    the procedure.  Otherwise the return value is 0.
  393.  *
  394.  * Side effects:
  395.  *    None.
  396.  *
  397.  *----------------------------------------------------------------------
  398.  */
  399.  
  400. Proc *
  401. TclIsProc(cmdPtr)
  402.     Command *cmdPtr;        /* Command to test. */
  403. {
  404.     if (cmdPtr->proc == InterpProc) {
  405.     return (Proc *) cmdPtr->clientData;
  406.     }
  407.     return (Proc *) 0;
  408. }
  409.  
  410. /*
  411.  *----------------------------------------------------------------------
  412.  *
  413.  * InterpProc --
  414.  *
  415.  *    When a Tcl procedure gets invoked, this routine gets invoked
  416.  *    to interpret the procedure.
  417.  *
  418.  * Results:
  419.  *    A standard Tcl result value, usually TCL_OK.
  420.  *
  421.  * Side effects:
  422.  *    Depends on the commands in the procedure.
  423.  *
  424.  *----------------------------------------------------------------------
  425.  */
  426.  
  427. static int
  428. InterpProc(clientData, interp, argc, argv)
  429.     ClientData clientData;    /* Record describing procedure to be
  430.                  * interpreted. */
  431.     Tcl_Interp *interp;        /* Interpreter in which procedure was
  432.                  * invoked. */
  433.     int argc;            /* Count of number of arguments to this
  434.                  * procedure. */
  435.     char **argv;        /* Argument values. */
  436. {
  437.     register Proc *procPtr = (Proc *) clientData;
  438.     register Arg *argPtr;
  439.     register Interp *iPtr = (Interp *) interp;
  440.     char **args;
  441.     CallFrame frame;
  442.     char *value;
  443.     int result;
  444.  
  445.     /*
  446.      * Set up a call frame for the new procedure invocation.
  447.      */
  448.  
  449.     iPtr = procPtr->iPtr;
  450.     Tcl_InitHashTable(&frame.varTable, TCL_STRING_KEYS);
  451.     if (iPtr->varFramePtr != NULL) {
  452.     frame.level = iPtr->varFramePtr->level + 1;
  453.     } else {
  454.     frame.level = 1;
  455.     }
  456.     frame.argc = argc;
  457.     frame.argv = argv;
  458.     frame.callerPtr = iPtr->framePtr;
  459.     frame.callerVarPtr = iPtr->varFramePtr;
  460.     iPtr->framePtr = &frame;
  461.     iPtr->varFramePtr = &frame;
  462.     iPtr->returnCode = TCL_OK;
  463.  
  464.     /*
  465.      * Match the actual arguments against the procedure's formal
  466.      * parameters to compute local variables.
  467.      */
  468.  
  469.     for (argPtr = procPtr->argPtr, args = argv+1, argc -= 1;
  470.         argPtr != NULL;
  471.         argPtr = argPtr->nextPtr, args++, argc--) {
  472.  
  473.     /*
  474.      * Handle the special case of the last formal being "args".  When
  475.      * it occurs, assign it a list consisting of all the remaining
  476.      * actual arguments.
  477.      */
  478.  
  479.     if ((argPtr->nextPtr == NULL)
  480.         && (strcmp(argPtr->name, "args") == 0)) {
  481.         if (argc < 0) {
  482.         argc = 0;
  483.         }
  484.         value = Tcl_Merge(argc, args);
  485.         Tcl_SetVar(interp, argPtr->name, value, 0);
  486.         ckfree(value);
  487.         argc = 0;
  488.         break;
  489.     } else if (argc > 0) {
  490.         value = *args;
  491.     } else if (argPtr->defValue != NULL) {
  492.         value = argPtr->defValue;
  493.     } else {
  494.         Tcl_AppendResult(interp, "no value given for parameter \"",
  495.             argPtr->name, "\" to \"", argv[0], "\"",
  496.             (char *) NULL);
  497.         result = TCL_ERROR;
  498.         goto procDone;
  499.     }
  500.     Tcl_SetVar(interp, argPtr->name, value, 0);
  501.     }
  502.     if (argc > 0) {
  503.     Tcl_AppendResult(interp, "called \"", argv[0],
  504.         "\" with too many arguments", (char *) NULL);
  505.     result = TCL_ERROR;
  506.     goto procDone;
  507.     }
  508.  
  509.     /*
  510.      * Invoke the commands in the procedure's body.
  511.      */
  512.  
  513.     procPtr->refCount++;
  514.     result = Tcl_Eval(interp, procPtr->command);
  515.     procPtr->refCount--;
  516.     if (procPtr->refCount <= 0) {
  517.     CleanupProc(procPtr);
  518.     }
  519.     if (result == TCL_RETURN) {
  520.     result = iPtr->returnCode;
  521.     iPtr->returnCode = TCL_OK;
  522.     if (result == TCL_ERROR) {
  523.         Tcl_SetVar2(interp, "errorCode", (char *) NULL,
  524.             (iPtr->errorCode != NULL) ? iPtr->errorCode : "NONE",
  525.             TCL_GLOBAL_ONLY);
  526.         iPtr->flags |= ERROR_CODE_SET;
  527.         if (iPtr->errorInfo != NULL) {
  528.         Tcl_SetVar2(interp, "errorInfo", (char *) NULL,
  529.             iPtr->errorInfo, TCL_GLOBAL_ONLY);
  530.         iPtr->flags |= ERR_IN_PROGRESS;
  531.         }
  532.     }
  533.     } else if (result == TCL_ERROR) {
  534.     char msg[100];
  535.  
  536.     /*
  537.      * Record information telling where the error occurred.
  538.      */
  539.  
  540.     sprintf(msg, "\n    (procedure \"%.50s\" line %d)", argv[0],
  541.         iPtr->errorLine);
  542.     Tcl_AddErrorInfo(interp, msg);
  543.     } else if (result == TCL_BREAK) {
  544.     iPtr->result = "invoked \"break\" outside of a loop";
  545.     result = TCL_ERROR;
  546.     } else if (result == TCL_CONTINUE) {
  547.     iPtr->result = "invoked \"continue\" outside of a loop";
  548.     result = TCL_ERROR;
  549.     }
  550.  
  551.     /*
  552.      * Delete the call frame for this procedure invocation (it's
  553.      * important to remove the call frame from the interpreter
  554.      * before deleting it, so that traces invoked during the
  555.      * deletion don't see the partially-deleted frame).
  556.      */
  557.  
  558.     procDone:
  559.     iPtr->framePtr = frame.callerPtr;
  560.     iPtr->varFramePtr = frame.callerVarPtr;
  561.     TclDeleteVars(iPtr, &frame.varTable);
  562.     return result;
  563. }
  564.  
  565. /*
  566.  *----------------------------------------------------------------------
  567.  *
  568.  * ProcDeleteProc --
  569.  *
  570.  *    This procedure is invoked just before a command procedure is
  571.  *    removed from an interpreter.  Its job is to release all the
  572.  *    resources allocated to the procedure.
  573.  *
  574.  * Results:
  575.  *    None.
  576.  *
  577.  * Side effects:
  578.  *    Memory gets freed, unless the procedure is actively being
  579.  *    executed.  In this case the cleanup is delayed until the
  580.  *    last call to the current procedure completes.
  581.  *
  582.  *----------------------------------------------------------------------
  583.  */
  584.  
  585. static void
  586. ProcDeleteProc(clientData)
  587.     ClientData clientData;        /* Procedure to be deleted. */
  588. {
  589.     Proc *procPtr = (Proc *) clientData;
  590.  
  591.     procPtr->refCount--;
  592.     if (procPtr->refCount <= 0) {
  593.     CleanupProc(procPtr);
  594.     }
  595. }
  596.  
  597. /*
  598.  *----------------------------------------------------------------------
  599.  *
  600.  * CleanupProc --
  601.  *
  602.  *    This procedure does all the real work of freeing up a Proc
  603.  *    structure.  It's called only when the structure's reference
  604.  *    count becomes zero.
  605.  *
  606.  * Results:
  607.  *    None.
  608.  *
  609.  * Side effects:
  610.  *    Memory gets freed.
  611.  *
  612.  *----------------------------------------------------------------------
  613.  */
  614.  
  615. static void
  616. CleanupProc(procPtr)
  617.     register Proc *procPtr;        /* Procedure to be deleted. */
  618. {
  619.     register Arg *argPtr;
  620.  
  621.     ckfree((char *) procPtr->command);
  622.     for (argPtr = procPtr->argPtr; argPtr != NULL; ) {
  623.     Arg *nextPtr = argPtr->nextPtr;
  624.  
  625.     ckfree((char *) argPtr);
  626.     argPtr = nextPtr;
  627.     }
  628.     ckfree((char *) procPtr);
  629. }
  630.